home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / cps / contract.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  19.9 KB  |  588 lines
  1. (* Copyright 1989 by AT&T Bell Laboratories *)
  2. functor Contract(val maxfree : int) :
  3.     sig val contract : {function: CPS.function,
  4.                 click: string->unit,
  5.                 last: bool,
  6.                 arg: System.Unsafe.object option}
  7.                     -> CPS.function
  8.         end =
  9. struct
  10.  
  11.  open Access CPS
  12.  structure CG = System.Control.CG
  13.  
  14.  fun map1 f (a,b) = (f a, b)
  15.  
  16.  fun last0[x]=x | last0(a::b)=last0 b | last0 _ = 0
  17.               
  18.  fun sameName(x,VAR y) = Access.sameName(x,y) 
  19.    | sameName(x,LABEL y) = Access.sameName(x,y) 
  20.    | sameName _ = ()
  21.  
  22.  val equalUptoAlpha =
  23.  let fun equ pairs =
  24.         let fun same(VAR a, VAR b) = 
  25.               let fun look((x,y)::rest) = a=x andalso b=y orelse look rest
  26.                 | look nil = false
  27.            in a=b orelse look pairs
  28.           end
  29.               | same(LABEL a, LABEL b) = same(VAR a, VAR b)
  30.               | same(INT i, INT j) = i=j
  31.               | same(REAL a, REAL b) = a=b
  32.               | same(STRING a, STRING b) = a=b
  33.           | same(a,b) = false
  34.             fun samefields((a,ap)::ar,(b,bp)::br) = ap=bp andalso same(a,b)
  35.                                              andalso samefields(ar,br)
  36.               | samefields(nil,nil) = true
  37.               | samefields _ = false
  38.         fun samewith p = equ (p::pairs)
  39.             fun all2 f (e::r,e'::r') = f(e,e') andalso all2 f (r,r')
  40.               | all2 f (nil,nil) = true
  41.               | all2 f _ = false
  42.             val rec sameexp = 
  43.          fn (SELECT(i,v,w,e),SELECT(i',v',w',e')) =>
  44.              i=i' andalso same(v,v') andalso samewith(w,w') (e,e')
  45.               | (RECORD(k,vl,w,e),RECORD(k',vl',w',e')) =>
  46.              (k = k') andalso samefields(vl,vl') andalso samewith (w,w') (e,e')
  47.               | (OFFSET(i,v,w,e),OFFSET(i',v',w',e')) =>
  48.              i=i' andalso same(v,v') andalso samewith(w,w') (e,e')
  49.               | (SWITCH(v,c,el),SWITCH(v',c',el')) =>
  50.             same(v,v') andalso all2 (samewith(c,c')) (el,el')
  51.           | (APP(f,vl),APP(f',vl')) => same(f,f') andalso all2 same (vl,vl')
  52.               | (FIX(l,e),FIX(l',e')) => (* punt! *) false
  53.           | (BRANCH(i,vl,c,e1,e2),BRANCH(i',vl',c',e1',e2')) =>
  54.             i=i' andalso all2 same (vl,vl') 
  55.             andalso samewith(c,c') (e1,e1')
  56.             andalso samewith(c,c') (e2,e2')
  57.           | (LOOKER(i,vl,w,e),LOOKER(i',vl',w',e')) =>
  58.            i=i' andalso all2 same (vl,vl') andalso samewith(w,w')(e,e')
  59.           | (SETTER(i,vl,e),SETTER(i',vl',e')) =>
  60.            i=i' andalso all2 same (vl,vl') andalso sameexp(e,e')
  61.           | (ARITH(i,vl,w,e),ARITH(i',vl',w',e')) =>
  62.            i=i' andalso all2 same (vl,vl') andalso samewith(w,w')(e,e')
  63.           | (PURE(i,vl,w,e),PURE(i',vl',w',e')) =>
  64.            i=i' andalso all2 same (vl,vl') andalso samewith(w,w')(e,e')
  65.           | _ => false
  66.          in sameexp
  67.         end
  68.    in equ nil
  69.   end
  70.  
  71.  datatype arity = BOT 
  72.         | UNK  (* an arg seen that isn't a known record *)
  73.         | COUNT of int * bool (* int is # of record fields;
  74.                bool is whether any arguments were unknown records*)
  75.         | TOP
  76.  
  77.  datatype info = FNinfo of {arity: arity list ref,
  78.                 args: lvar list,
  79.                 body : cexp option ref,
  80.                 specialuse: int ref option ref}
  81.            | RECinfo of (value * accesspath) list
  82.            | SELinfo of int * value
  83.            | ARGinfo of {biggestSEL: int ref}
  84.            | OFFinfo of int * value
  85.            | MISCinfo
  86.  
  87. fun contract {function=(fvar,fargs,cexp), click, last, arg} =
  88. let
  89.  val debug = !System.Control.CG.misc1 (* false *)
  90.  fun debugprint s = if debug then System.Print.say(s) else ()
  91.  fun debugflush() = if debug then System.Print.flush() else ()
  92.  
  93.  (* Note that maxfree has already been reduced by 1 (in CPScomp)
  94.     on most machines to allow for an arithtemp *)
  95.  val maxregs = min(!CG.maxregs, maxfree)- !CG.calleesaves
  96.  
  97.      val say = debugprint
  98.      fun sayv(VAR v) = say(Access.lvarName v)
  99.         | sayv(LABEL v) = say("(L)" ^ Access.lvarName v)
  100.     | sayv(INT i) = say(makestring i)
  101.     | sayv(REAL r) = say r
  102.     | sayv(STRING s) = (say "\""; say s; say "\"")
  103.  
  104.  val botlist = if !CG.flattenargs then map (fn _ => BOT)
  105.                   else map (fn _ => TOP)
  106.  exception Escapemap
  107.  val m : {info: info, used : int ref, escape : int ref} Intmap.intmap =
  108.          Intmap.new(128, Escapemap)
  109.  val get = Intmap.map m
  110.  val get = fn i => get i handle Escapemap => ErrorMsg.impossible
  111.                       ("Escapemap on " ^ makestring i)
  112.  val enter = Intmap.add m
  113.  fun use(VAR v) = inc(#used(get v))
  114.    | use(LABEL v) = inc(#used(get v))
  115.    | use _ = ()
  116.  fun used v = !(#used(get v)) > 0
  117.  
  118.  fun escape(VAR v) = let val {escape,used,...} = get v
  119.               in inc escape; inc used
  120.              end
  121.    | escape(LABEL v) = escape(VAR v)
  122.    | escape _ = ()
  123.  
  124.  fun selectFrom(VAR v,i) =
  125.        let val {info,used,escape,...} = get v
  126.        in inc used; if !CG.selectopt then () else inc escape;
  127.       case info
  128.        of ARGinfo{biggestSEL as ref j} => biggestSEL := max(i,j)
  129.         | _ => ()
  130.        end
  131.    | selectFrom(LABEL v, i) = selectFrom(VAR v, i)
  132.    | selectFrom _ = ()
  133.  
  134.  fun enterField(v, SELp(i,_)) = selectFrom(v,i)
  135.    | enterField(v, _) = escape(v)
  136.  
  137.  fun enterREC(w,vl) = enter(w,{info=RECinfo vl, escape=ref 0,used=ref 0})
  138.  fun enterARG w = enter(w,{info=ARGinfo{biggestSEL=ref ~1},
  139.                escape=ref 0, used = ref 0})
  140.  fun enterMISC w = enter(w,{info=MISCinfo, escape=ref 0, used = ref 0})
  141.  
  142.  fun enterFN (f,vl,cexp) =
  143.         (enter(f,{escape=ref 0,used=ref 0,
  144.              info=FNinfo{arity=ref(botlist vl), args=vl, 
  145.              body= ref(if !CG.betacontract then SOME cexp else NONE),
  146.              specialuse=ref NONE}});
  147.          app enterARG vl)
  148.  
  149.  local exception Found
  150.  in fun findFetch(v,k) body =
  151.       (* find whether field k of variable v is guaranteed to exist *)
  152.       let fun f(RECORD(_, fields,_,e)) = (app g fields; f e)
  153.      | f(SELECT(i,VAR v',w,e)) = if v=v' andalso i=k then raise Found
  154.                     else f e
  155.      | f(SELECT(_,_,_,e)) = f e
  156.      | f(OFFSET(_,_,_,e)) = f e
  157.      | f(FIX(_,e)) = f e
  158.      | f(BRANCH(_,_,_,e1,e2)) = findFetch(v,k) e1 andalso
  159.                     findFetch(v,k) e2
  160.      | f(LOOKER(_,_,_,e)) = f e
  161.      | f(SETTER(_,_,e)) = f e
  162.      | f(ARITH(_,_,_,e)) = f e
  163.      | f(PURE(_,_,_,e)) = f e
  164.      | f(SWITCH(_,_,el)) = not(exists (not o findFetch(v,k)) el)
  165.      | f _ = false
  166.        and g(VAR v',SELp(i,_)) = 
  167.               if v=v' andalso i=k then raise Found else ()
  168.      | g _  = ()
  169.       in f body 
  170.      handle Found => true
  171.       end
  172.  end
  173.  
  174.  fun don'tReduce(VAR g) = (case get g
  175.                 of {info=FNinfo{body,...},...} => body := NONE
  176.                  | _ => ())
  177.    | don'tReduce(LABEL g) = don'tReduce(VAR g)
  178.    | don'tReduce _ = ()
  179.  
  180.  fun SELECTandAPP(APP(g,_)) = SOME g
  181.    | SELECTandAPP(SELECT(_,_,_,e)) = SELECTandAPP e
  182.    | SELECTandAPP _ = NONE
  183.  
  184.  fun checkreduce(f,vl,body) =
  185.        (if last then () 
  186.     else case (vl,body)
  187.      of ([a,c],FIX([(h,[b,k],body)],APP(VAR c',[VAR h']))) =>
  188.         (case (c=c' andalso h=h', SELECTandAPP(body))
  189.           of (true,SOME g) => don'tReduce g
  190.            | _ => ())
  191.       | _ => ();
  192.        case get f of
  193.      {escape=ref 0,used=ref 2,
  194.       info=FNinfo{specialuse=ref(SOME(ref 1)),body=b,...},...} =>
  195.          if not (!CG.ifidiom) then b:=NONE else ()
  196.        | {escape=ref 0,used=ref i,
  197.     info=FNinfo{body=b,arity as ref al,...},...} =>
  198.           let fun loop(v::vl,a::al, headroom) =
  199.            (case (get v, a)
  200.              of ({used=ref 0,...},_) =>
  201.                 if !CG.dropargs 
  202.                  then COUNT(0,true)::loop(vl,al,headroom+1)
  203.                  else a::loop(vl,al,headroom)
  204.               | ({escape=ref 0,...}, COUNT(c,false)) => 
  205.                   if headroom+1-c >= 0
  206.                  then a::loop(vl,al,headroom+1-c)
  207.                  else TOP::loop(vl,al,headroom)
  208.               | ({escape=ref 0,info=ARGinfo{biggestSEL=ref j},...},
  209.              COUNT(c,true)) => 
  210.                  if j=c-1 andalso findFetch(v,c-1) body
  211.                  andalso headroom+1-c >= 0
  212.                  then a::loop(vl,al,headroom+1-c)
  213.                  else TOP::loop(vl,al,headroom)
  214.               | _ => TOP::loop(vl,al,headroom))
  215.             | loop _ = []
  216.           in if i>1 then b := NONE else ();
  217.         (* We have maxregs registers; one might be used for a closure
  218.            argument; so the most arguments we can give a function 
  219.            here is maxregs-1  *)
  220.          arity := loop(vl,al,maxregs-1-length(al))
  221.           end
  222.       | {info=FNinfo{body=b,...},...} =>
  223.         (b := NONE;
  224.          if last
  225.          then ()
  226.          else (case body of
  227.             APP(g, _) => don'tReduce g
  228.                | _ => ())))
  229.  
  230.  exception ConstFold
  231.  
  232.  val rec pass1 = 
  233.   fn RECORD(_, vl,w,e) => (enterREC(w,vl); app enterField vl; pass1 e)
  234.    | SELECT (i,v,w,e) => 
  235.         (enter(w,{info=SELinfo(i,v), escape=ref 0, used = ref 0});
  236.          selectFrom(v,i);
  237.          pass1 e)
  238.    | OFFSET (i,v,w,e) => 
  239.         (enter(w,{info=OFFinfo(i,v), escape=ref 0, used=ref 0});
  240.          escape v; pass1 e)
  241.    | APP(LABEL f, vl) => pass1(APP(VAR f, vl))
  242.    | APP(VAR f, vl) =>
  243.      ((case get f
  244.     of {info=FNinfo{arity as ref al,...},...} =>
  245.      let fun loop(BOT::r,vl0 as VAR v :: vl, n) =
  246.           (case get v
  247.             of {info=RECinfo wl,...} =>
  248.                 loop(COUNT(length wl,false)::r,vl0,n)
  249.              | _ => UNK::loop(r,vl,n+1))
  250.            | loop(UNK::r,vl0 as VAR v :: vl, n) =
  251.           (case get v
  252.             of {info=RECinfo wl,...} =>
  253.                    loop(COUNT(length wl,true)::r,vl0,n)
  254.              | _ => UNK::loop(r,vl,n+1))
  255.            | loop((cnt as COUNT(a,unk))::r, VAR v::vl,n) = 
  256.           (case get v of
  257.              {info=RECinfo wl, ...} =>
  258.              if a = length wl
  259.              then cnt::loop(r,vl,n+1)
  260.              else TOP::loop(r,vl,n+1)
  261.            | _ => COUNT(a,true)::loop(r,vl,n+1))
  262.            | loop(_::r, _::vl,n) = TOP::loop(r,vl,n+1)
  263.            | loop _ = []
  264.      in arity := loop(al,vl,0)
  265.      end
  266.     | _ => ());
  267.       use(VAR f); app escape vl)
  268.    | APP(f, vl) => (use f; app escape vl)
  269.    | FIX(l, e) => (app enterFN l;
  270.            app (fn (f,vl,body) => pass1 body) l;
  271.            pass1 e;
  272.            app checkreduce l)
  273.    | SWITCH(v,_,el) => (use v; app pass1 el)
  274.    | BRANCH(i,vl,c,e1 as APP(VAR f1, [INT 1]),
  275.            e2 as APP(VAR f2, [INT 0])) =>
  276.      (case get f1
  277.        of {info=FNinfo{body=ref(SOME(BRANCH(P.ineq,[INT 0, VAR w2],_,_,_))),
  278.                args=[w1],specialuse,...},...} =>
  279.            if f1=f2 andalso w1=w2 
  280.            then let val {used,...}=get w1
  281.              in specialuse := SOME used
  282.             end
  283.            else ()
  284.         | _ => ();
  285.       app escape vl; pass1 e1; pass1 e2)
  286.    | BRANCH(P.boxed,[v],_,e1,e2) => (escape v; pass1 e1; pass1 e2)
  287.    | BRANCH(P.unboxed,[v],_,e1,e2) => (escape v; pass1 e1; pass1 e2)
  288.    | BRANCH(i,vl,_,e1,e2) => (app escape vl; pass1 e1; pass1 e2)
  289.       (* the abovementioned escape is necessary, instead of use,
  290.         in case record pointers are compared for equality *)
  291.    | SETTER(i,vl,e) => (app escape vl; pass1 e)
  292.    | LOOKER(i,vl,w,e) => (app use vl; enterMISC w; pass1 e)
  293.    | ARITH(i,vl,w,e) => (app use vl; enterMISC w; pass1 e)
  294.    | PURE(i,vl,w,e) => (app escape vl; enterMISC w; pass1 e)
  295.  
  296.  exception Beta
  297.  val m2 : value Intmap.intmap = Intmap.new(32, Beta)
  298.  local val mapm2 = Intmap.map m2
  299.    in fun ren(v0 as VAR v) = (ren(mapm2 v) handle Beta => v0)
  300.     | ren(v0 as LABEL v) = (ren(mapm2 v) handle Beta => v0)
  301.     | ren x = x
  302.  end
  303.  fun newname vw = (sameName vw; Intmap.add m2 vw)
  304.  fun newnames(v::vl, w::wl) = (newname(v,w); newnames(vl,wl))
  305.    | newnames _ = ()
  306.  
  307.  fun makeSELECT(i,v,w,e) =
  308.        case ren v
  309.         of v' as VAR v'' =>
  310.             (case get v''
  311.               of {info=RECinfo vl,...} =>
  312.                 (click "d"; newname(w,#1(nth(vl,i))); e())
  313.                | _ => SELECT(i,v', w, e()))
  314.      | v' => SELECT(i,v',w,e())
  315.  
  316.   fun setter (P.update, [_, _, INT _]) = P.unboxedupdate
  317.     | setter (P.update, [_, _, REAL _]) = P.boxedupdate
  318.     | setter (P.update, [_, _, STRING _]) = P.boxedupdate
  319.     | setter (P.update, [_, _, VAR v]) = (case #info(get v)
  320.      of (FNinfo _) => P.boxedupdate
  321.       | (RECinfo _) => P.boxedupdate
  322.       | (OFFinfo _) => P.boxedupdate
  323.       | _ => P.update
  324.     (* end case *))
  325.     | setter (i, _) = i
  326.  
  327.  val rec reduce = fn cexp => g NONE cexp
  328.  and g = fn hdlr =>
  329.  let val rec g' =
  330.    fn RECORD (k,vl,w,e) =>
  331.       let val {info=RECinfo _,used=ref use,...} = get w
  332.       in if use=0 andalso !CG.deadvars
  333.      then (click "b"; g' e)
  334.      else RECORD(k,map (map1 ren) vl, w, g' e)
  335.       end
  336.     | SELECT(i,v,w,e) =>
  337.       if not(used w) andalso !CG.deadvars then (click "c"; g' e)
  338.       else makeSELECT(i,v,w, fn () => g' e)
  339.     | OFFSET(i,v,w,e) => OFFSET(i,ren v,w,g' e)
  340.     | APP(f, vl) =>
  341.       let fun trybeta(f',fv) = 
  342.       (case (get fv, vl)
  343.        of ({info=FNinfo{args,body as ref(SOME b),...},...},_) =>
  344.             (newnames(args, map ren vl); body := NONE; g' b)
  345.         | ({info=FNinfo{arity=ref al,...},escape=ref 0,...}, _) =>
  346.           let fun loop(COUNT(cnt,_) :: r, v::vl,args) =
  347.               let fun g(i,args) = 
  348.                   if i=cnt then loop(r,vl,args)
  349.                   else let val z = mkLvar()
  350.                     in enter(z,{info=SELinfo(i,v),
  351.                             escape=ref 3,used=ref 3});
  352.                        makeSELECT(i,v,z,
  353.                            fn ()=>g(i+1, ren(VAR z) :: args))
  354.                        end
  355.                in g(0,args)
  356.               end
  357.             | loop(_::r,v::vl,args) = loop(r,vl, ren v :: args)
  358.             | loop (_,_,args) = APP(f', rev args)
  359.           in loop(al,vl,nil)
  360.           end
  361.         | (_,vl') => APP(f', map ren vl'))
  362.       in case ren f
  363.     of f' as VAR fv => trybeta(f',fv)
  364.      | f' as LABEL fv => trybeta(f',fv)
  365.      | f' => APP(f', map ren vl)
  366.       end
  367.     | FIX(l,e) =>
  368.       let fun process_args(f,vl,body) = 
  369.            case get f
  370.         of {info=FNinfo{body=ref NONE,arity=ref al,...},
  371.                 escape=ref 0,...} =>
  372.               let fun vars 0 = []
  373.                 | vars i = mkLvar()::vars(i-1)
  374.               fun newargs(COUNT(j,_) :: r,v::vl) =
  375.                   let val new = vars j
  376.                   in app enterMISC new;
  377.                  enterREC(v, map (fn x =>(VAR x, OFFp 0)) new);
  378.                  click "f";
  379.                  new @ newargs(r,vl)
  380.                   end
  381.                 | newargs(_::r,v::vl) = v::newargs(r,vl)
  382.                 | newargs _ = []
  383.               in (f, newargs(al,vl), body)
  384.               end
  385.          | _ => (f, vl, body)
  386.  
  387.       fun drop_dead ((f,vl,body as BRANCH(_,[_,VAR w],_,_,_))::rest) = 
  388.           (case (get f, get w)
  389.         of ({info=FNinfo{body = b as ref(SOME _),...}, used=ref 2,...},
  390.             {used=ref uw,...})=> 
  391.             (if uw<>1 then (b:=NONE; 
  392.                     (f,vl,body)::drop_dead rest)
  393.                   else (click "E";
  394.                      drop_dead rest))
  395.          | ({info=FNinfo{body=ref(SOME _),...}, used=ref 1,...},
  396.             _)=> 
  397.             (click "e";
  398.              drop_dead rest)
  399.          | ({info=FNinfo{body as ref(SOME _),...}, used=ref 0,...},
  400.             _)=> 
  401.             (click "g";
  402.              body:=NONE;
  403.              drop_dead rest)
  404.          | _ => (f,vl, body) :: drop_dead rest)
  405.         | drop_dead ((f,vl,body)::rest) = 
  406.           (case get f
  407.         of {info=FNinfo{body=ref(SOME _),...}, used=ref 1,...}=>
  408.             (click "e";
  409.              drop_dead rest)
  410.          | {info=FNinfo{body as ref(SOME _),...}, used=ref 0,...}=>
  411.             (click "g";
  412.              body := NONE;
  413.              drop_dead rest)
  414.          | _ => (f,vl,body) :: drop_dead rest)
  415.         | drop_dead nil = nil
  416.       fun reduce_body (f,vl,body) = (f,vl,reduce body)
  417.        in case  map reduce_body (drop_dead (map process_args l))
  418.        of nil => g' e
  419.         | l' => FIX(l', g' e)
  420.       end
  421.     | SWITCH(v,c,el) => 
  422.         (case ren v
  423.           of v' as INT i => 
  424.             if !CG.switchopt 
  425.                 then (click "h"; 
  426.                   newname(c,INT 0);
  427.                   g' (nth(el,i)))
  428.                 else SWITCH(v', c, map g' el)
  429.            | v' => SWITCH(v',c, map g' el))
  430.     | LOOKER(P.gethdlr,_,w,e) =>
  431.       (if !CG.handlerfold
  432.     then case hdlr of
  433.      NONE => if used w then LOOKER(P.gethdlr,[],w,g (SOME(VAR w)) e)
  434.          else (click "i"; g' e)
  435.        | SOME w' => (click "j"; newname(w,w'); g' e)
  436.     else LOOKER(P.gethdlr,[],w,g (SOME(VAR w)) e))
  437.     | SETTER(P.sethdlr,[v as VAR vv],e) =>
  438.       let val v' as VAR vv' = ren v
  439.       val e' = g (SOME v') e
  440.       in if !CG.handlerfold
  441.     then case hdlr of
  442.        NONE => SETTER(P.sethdlr,[v'],e')
  443.      | SOME (v'' as VAR vv'') => if vv'=vv'' then (click "k"; e')
  444.                else SETTER(P.sethdlr,[v'],e')
  445.     else SETTER(P.sethdlr,[v'],e')
  446.       end
  447. (**    | SETTER(i,vl,e) => SETTER(i, map ren vl, g' e)**)
  448.     | SETTER(i, vl, e) => let
  449.     val vl' = map ren vl
  450.     in
  451.       SETTER(setter (i, vl'), vl', g' e)
  452.     end
  453.     | LOOKER(i,vl,w,e) => 
  454.       if not(used w) andalso !CG.deadvars
  455.           then (click "m"; g' e)
  456.           else LOOKER(i, map ren vl, w, g' e)
  457.     | ARITH(i,vl,w,e) =>
  458.          let val vl' = map ren vl
  459.           in  (if !CG.arithopt
  460.              then (newname(w,arith(i, vl')); g' e)
  461.              else raise ConstFold)
  462.          handle ConstFold => ARITH(i, vl', w, g' e)
  463.               | Overflow => ARITH(i, vl', w, g' e)
  464.          end
  465.     | PURE(i,vl,w,e) =>
  466.       if not(used w) andalso !CG.deadvars
  467.     then (click "m"; g' e)
  468.     else let val vl' = map ren vl
  469.           in  (if !CG.arithopt
  470.              then (newname(w,pure(i, vl')); g' e)
  471.              else raise ConstFold)
  472.          handle ConstFold => PURE(i, vl', w, g' e)
  473.          end
  474.     | BRANCH(i,vl,c,e1,e2) =>
  475.        let val vl' = map ren vl
  476.        fun h() = (if !CG.branchfold andalso equalUptoAlpha(e1,e2)
  477.              then (click "z"; newname(c,INT 0); g' e1)
  478.              else if !CG.comparefold
  479.              then if branch(i,vl')
  480.                then (newname(c,INT 0); g' e1)
  481.                else (newname(c,INT 0); g' e2)
  482.              else raise ConstFold)
  483.          handle ConstFold => BRANCH(i, vl', c, g' e1, g' e2)
  484.         in case (e1,e2) 
  485.             of (APP(VAR f, [INT 1]), APP(VAR f', [INT 0])) =>
  486.         (case (f=f', get f)
  487.                   of (true, 
  488.                   {info=FNinfo{args,body as ref(SOME(BRANCH(_,_,c',a,b))),
  489.                           ...},...}) =>
  490.                          (newname(c', VAR c); 
  491.                   body:=NONE;
  492.               g'(BRANCH(i,vl,c,a,b)))
  493.                | _ => h())
  494.          | _ => h()
  495.        end
  496.   in g'
  497.  end
  498.  
  499.  and branch =
  500.     fn (P.unboxed, vl) => not(branch(P.boxed, vl))
  501.      | (P.boxed, [INT _]) => (click "n"; false)
  502.      | (P.boxed, [STRING s]) => (click "o"; true)
  503.      | (P.boxed, [VAR v]) => 
  504.      (case get v
  505.        of  {info=RECinfo _, ...} => (click "p"; true)
  506.         | _ => raise ConstFold)
  507.      | (P.<, [VAR v, VAR w]) => 
  508.       if v=w then (click "v"; false) else raise ConstFold
  509.      | (P.<, [INT i, INT j]) => (click "w"; i<j)
  510.      | (P.>, [w,v]) => branch(P.<,[v,w])
  511.      | (P.<=, [w,v]) => branch(P.>=,[v,w])
  512.      | (P.>=, vl) => not(branch(P.<,vl))
  513.      | (P.gequ, [v,w]) => not(branch(P.lessu, [v,w]))
  514.      | (P.lessu, [VAR v, VAR w]) => if v=w then (click "v"; false) 
  515.                        else raise ConstFold
  516.      | (P.lessu, [INT i, INT j]) => 
  517.             (click "w"; 
  518.              if j<0 then i>=0 orelse i<j
  519.                else i>=0 andalso i<j)
  520.      | (P.ieql, [VAR v, VAR w]) => (if v=w then (click "v"; true)
  521.                     else raise ConstFold)
  522.      | (P.ieql, [INT i, INT j]) => (click "w"; i=j)
  523.      | (P.ineq, [v,w]) => not(branch(P.ieql,[w,v]))
  524.      | _ => raise ConstFold
  525.  
  526.   and arith =
  527.     fn (P.*, [INT 1, v]) => (click "F"; v)
  528.      | (P.*, [v, INT 1]) => (click "G"; v)
  529.      | (P.*, [INT 0, _]) => (click "H"; INT 0)
  530.      | (P.*, [_, INT 0]) => (click "I"; INT 0)
  531.      | (P.*, [INT i, INT j]) =>
  532.         let val x = i*j in x+x; click "J"; INT x end
  533.      | (P.div, [v, INT 1]) => (click "K"; v)
  534.      | (P.div, [INT i, INT 0]) => raise ConstFold
  535.      | (P.div, [INT i, INT j]) =>
  536.         let val x = i quot j in x+x; click "L"; INT x end
  537.      | (P.+, [INT 0, v]) => (click "M"; v)
  538.      | (P.+, [v, INT 0]) => (click "N"; v)
  539.      | (P.+, [INT i, INT j]) =>
  540.            let val x = i+j in x+x; click "O"; INT x end
  541.      | (P.-, [v, INT 0]) => (click "P"; v)
  542.      | (P.-, [INT i, INT j]) =>
  543.            let val x = i-j in x+x; click "Q"; INT x end
  544.      | (P.~, [INT i]) =>
  545.           let val x = ~i in x+x; click "X"; INT x end
  546.      | _ => raise ConstFold
  547.  
  548.   and pure =
  549.     fn (P.rshift, [INT i, INT j]) => (click "R"; INT(Bits.rshift(i,j)))
  550.      | (P.rshift, [INT 0, _]) => (click "S"; INT 0)
  551.      | (P.rshift, [v, INT 0]) => (click "T"; v)
  552.      | (P.length, [STRING s]) => (click "V"; INT(size s))
  553. (*         | (P.ordof, [STRING s, INT i]) => (click "W"; INT(ordof(s,i))) *)
  554.      | (P.lshift, [INT i, INT j]) =>
  555.                (let val x = Bits.lshift(i,j)
  556.             in x+x; click "Y"; INT x
  557.             end handle Overflow => raise ConstFold)
  558.      | (P.lshift, [INT 0, _]) => (click "Z"; INT 0)
  559.      | (P.lshift, [v, INT 0]) => (click "1"; v)
  560.      | (P.orb, [INT i, INT j]) => (click "2"; INT(Bits.orb(i,j)))
  561.      | (P.orb, [INT 0, v]) => (click "3"; v)
  562.      | (P.orb, [v, INT 0]) => (click "4"; v)
  563.      | (P.xorb, [INT i, INT j]) => (click "5"; INT(Bits.xorb(i,j)))
  564.      | (P.xorb, [INT 0, v]) => (click "6"; v)
  565.      | (P.xorb, [v, INT 0]) => (click "7"; v)
  566.      | (P.notb, [INT i]) => (click "8"; INT(Bits.notb i))
  567.      | (P.andb, [INT i, INT j]) => (click "9"; INT(Bits.andb(i,j)))
  568.      | (P.andb, [INT 0, _]) => (click "0"; INT 0)
  569.      | (P.andb, [_, INT 0]) => (click "T"; INT 0)
  570.      | (P.real, [INT i]) => (REAL(makestring i ^ ".0"))  (* isn't this cool? *)
  571.      | _ => raise ConstFold
  572.  
  573.  val _ = (debugprint "\nContract: "; debugflush())
  574.  fun ssss cexp = if debug then (debugprint "\nAfter contract: \n"; 
  575.                 if !CG.misc4=16 then
  576.                     CPSprint.show System.Print.say cexp
  577.                 else ();
  578.                 cexp)
  579.          else cexp
  580.  
  581. in enterMISC fvar; app enterMISC fargs;
  582.    pass1 cexp;
  583.    (fvar, fargs, ssss(reduce cexp))
  584. end
  585.  
  586. end
  587.  
  588.